import Control.Monad
import Control.Monad.State
import Data.Array

import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.TTF as TTF

data Terrain = Terrain { tSymbol :: Char
                       , tIsSolid :: Bool
                       } deriving (Show)

type GameMap = Array (Int, Int) Terrain

data GameMode = Setup | TitleScreen | MainScreen
                deriving (Show)

data Player = Player { pPos :: (Int, Int)
                     , pSymbol :: Char
                     } deriving (Show)

data GameState = GameState { sMode :: GameMode
                           , sGameMap :: GameMap
                           , sPlayer :: Player
                           } deriving (Show)

initialMap = array ((1, 1), (10, 10)) [((x, y),
                                       if x == 1 || y == 1 || x == 10 || y == 10 then
                                           wall
                                       else
                                           empty)
                                      | x <- [1..10], y <- [1..10]]

initPlayer = Player { pPos = (5, 5), pSymbol = '@' }

initialState = GameState {
                 sMode = Setup
               , sGameMap = initialMap
               , sPlayer = initPlayer
               }

wall = Terrain { tSymbol = 'X', tIsSolid = True }
empty = Terrain { tSymbol = ' ', tIsSolid = False }

tileHeight = 20
tileWidth = 20
tileFontSize = 20

white = Color 255 255 255

data PlayerAction = Move Direction | NoAction
data Direction = DUp | DDown | DLeft | DRight

-- Set up the SDL system, begin event loop.
main :: IO ()
main = do
  SDL.init [InitEverything]
  TTF.init
  setVideoMode 800 600 32 []
  -- Setup
  renderScreen initialState
  gameLoop $ initialState { sMode = TitleScreen }

gameLoop :: GameState -> IO ()
gameLoop state = do
  renderScreen state
  e <- waitEvent
  let (continue, newState) = runState (processEvent e) state
  if continue then
      gameLoop newState
    else
        return ()

-- Process user input.
processEvent :: Event -> State GameState Bool
processEvent event = do
  case event of
    Quit -> return False
    KeyUp (Keysym SDLK_q _ _) -> return False
    KeyUp (Keysym key _ _) -> do 
              playerAction (mapKeyToAction key)
              return True
    _ -> return True

mapKeyToAction :: SDLKey -> PlayerAction
mapKeyToAction SDLK_w = (Move DUp)
mapKeyToAction SDLK_a = (Move DLeft)
mapKeyToAction SDLK_s = (Move DDown)
mapKeyToAction SDLK_d = (Move DRight)
mapKeyToAction _ = NoAction

playerAction :: PlayerAction -> State GameState ()
playerAction action = do
  state <- get
  let mode = sMode state
  case mode of
    TitleScreen -> put $ state { sMode = MainScreen }
    MainScreen -> 
        case action of
          Move dir ->
              let player = sPlayer state
                  (x, y) = pPos player
                  map = sGameMap state
                  limits = bounds map
                  (newX, newY) = move dir (x, y) limits in
              if not $ tIsSolid $ (sGameMap state) ! (newX, newY) then
                  updatePlayerPosition (newX, newY)
              else
                  return ()
          NoAction ->return ()

move :: Direction -> (Int, Int) -> ((Int, Int), (Int, Int)) -> (Int, Int)
move dir (x, y) ((minx, miny), (maxx, maxy)) = 
    case dir of
      DUp -> if y > miny then (x, y - 1) else (x, y)
      DDown -> if y < maxy then (x, y + 1) else (x, y)
      DLeft -> if x > minx then (x - 1, y) else (x, y)
      DRight -> if x < maxx then (x + 1, y) else (x, y)

updatePlayerPosition :: (Int, Int) -> State GameState ()
updatePlayerPosition (x, y) = do
  state <- get
  put $ state { sPlayer = (sPlayer state) { pPos = (x, y) } }

-- Render the screen.
renderScreen :: GameState -> IO ()
renderScreen state = do
  case sMode state of
    Setup -> do
      screen <- getVideoSurface
      font <- openFont "resources/DroidSansMonoDotted.ttf" 96
      title <- renderTextSolid font "Artificer" white
      blitSurface title Nothing screen Nothing
      SDL.flip screen
      return ()
    TitleScreen -> return ()
    MainScreen -> do
      screen <- getVideoSurface
      fillRect screen Nothing (Pixel 0)
      font <- openFont "resources/DroidSansMonoDotted.ttf" tileFontSize
      -- TODO(apm): Quit painting the whole screen like a noob.
      forM (assocs (sGameMap state))
               (\((x, y), s) -> do
                  char <- renderTextSolid font [tSymbol s] white
                  blitSurface char Nothing
                              screen $ Just $ makeTileRect x y
                  return ())

      let player = sPlayer state
      playerChar <- renderTextSolid font [pSymbol player] white
      let (x, y) = pPos player
      blitSurface playerChar Nothing screen $ Just $ makeTileRect x y
      SDL.flip screen
      return ()


makeTileRect x y =
    Rect (x * tileWidth) (y * tileHeight) ((x + 1) * tileWidth) ((y + 1) * tileHeight)